home *** CD-ROM | disk | FTP | other *** search
/ User's Choice Windows CD / User's Choice Windows CD (CMS Software)(1993).iso / windows5 / xwinc100.zip / CONTRIB-.00 / CONTRIB- / contrib / examples / CLX / hello.l < prev    next >
Lisp/Scheme  |  1989-12-07  |  2KB  |  66 lines
  1. ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
  2.  
  3. (in-package 'xlib :use '(lisp))
  4.  
  5. (defun hello-world (host &rest args &key (string "Hello World") (font "fixed"))
  6.   ;; CLX demo, says STRING using FONT in its own window on HOST
  7.   (let ((display nil)
  8.     (abort t))
  9.     (unwind-protect
  10.     (progn 
  11.       (setq display (open-display host))
  12.       (multiple-value-prog1
  13.         (let* ((screen (display-default-screen display))
  14.            (black (screen-black-pixel screen))
  15.            (white (screen-white-pixel screen))
  16.            (font (open-font display font))
  17.            (border 1)            ; Minimum margin around the text
  18.            (width (+ (text-width font string) (* 2 border)))
  19.            (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border)))
  20.            (x (truncate (- (screen-width screen) width) 2))
  21.            (y (truncate (- (screen-height screen) height) 2))
  22.            (window (create-window :parent (screen-root screen)
  23.                       :x x :y y :width width :height height
  24.                       :background black
  25.                       :border white
  26.                       :border-width 1
  27.                       :colormap (screen-default-colormap screen)
  28.                       :bit-gravity :center
  29.                       :event-mask '(:exposure :button-press)))
  30.            (gcontext (create-gcontext :drawable window
  31.                           :background black
  32.                           :foreground white
  33.                           :font font)))
  34.           ;; Set window manager hints
  35.           (set-wm-properties window
  36.                  :name 'hello-world
  37.                  :icon-name string
  38.                  :resource-name string
  39.                  :resource-class 'hello-world
  40.                  :command (list* 'hello-world host args)
  41.                  :x x :y y :width width :height height
  42.                  :min-width width :min-height height
  43.                  :input :off :initial-state :normal)
  44.           (map-window window)        ; Map the window
  45.           ;; Handle events
  46.           (event-case (display :discard-p t :force-output-p t)
  47.         (exposure  ;; Come here on exposure events
  48.           (window count)
  49.           (when (zerop count) ;; Ignore all but the last exposure event
  50.             (with-state (window)
  51.               (let ((x (truncate (- (drawable-width window) width) 2))
  52.                 (y (truncate (- (+ (drawable-height window)
  53.                            (max-char-ascent font))
  54.                         (max-char-descent font))
  55.                      2)))
  56.             ;; Draw text centered in widnow
  57.             (clear-area window)
  58.             (draw-glyphs window gcontext x y string)))
  59.             ;; Returning non-nil causes event-case to exit
  60.             nil))
  61.         (button-press () t)))  ;; Pressing any mouse-button exits
  62.         (setq abort nil)))
  63.       ;; Ensure display is closed when done
  64.       (when display
  65.     (close-display display :abort abort)))))
  66.